! Parallel class with pipelines for QuickPIC Open Source 1.0
! update: 04/18/2016

      module parallel_pipe_class

      use mpi
      use parallel_class

      implicit none

      private

      public :: parallel_pipe

      type, extends (parallel) :: parallel_pipe

         private
! nstage: number of pipeline stages
! stageid: pipeline stage id
! lidproc: local processor id
! lkstrt: idproc+1
! lgrp = local pipeline stage communicator
! lnvp = number of MPI nodes in the local pipeline stage

         integer :: nstage = 1
         integer :: stageid = 0
         integer :: lidproc
         integer :: lkstrt
         integer :: lgrp
         integer :: lnvp
         integer, dimension(:), pointer :: lidprocm => null()
         integer, dimension(:), pointer :: lkstrtm => null()
         integer, dimension(:), pointer :: lgrpm => null()
         integer, dimension(:), pointer :: lnvpm => null()

         contains

         generic :: new => init_parallel_pipe
         generic :: setmg => set_multigrid_parallel
         generic :: renewmg => renew_multigrid_parallel
         procedure :: getnstage
         procedure :: getstageid
         procedure :: getlidproc
         procedure :: getlkstrt
         procedure :: getlgrp
         procedure :: getlnvp
         procedure :: getlidprocm
         procedure :: getlkstrtm
         procedure :: getlgrpm
         procedure :: getlnvpm
         procedure, private :: init_parallel_pipe, set_multigrid_parallel,renew_multigrid_parallel

      end type parallel_pipe
! used by f77 subroutines
      integer :: nproc, lgrp, mreal, mint, mcplx, mdouble, lworld
      common /PPARMS/ nproc, lgrp, mreal, mint, mcplx, mdouble, lworld

      contains
!
      function getlidproc(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getlidproc

         getlidproc = this%lidproc

      end function getlidproc
!
      function getlkstrt(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getlkstrt

         getlkstrt = this%lkstrt

      end function getlkstrt
!
      function getlgrp(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getlgrp

         getlgrp = this%lgrp

      end function getlgrp
!
      function getlnvp(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getlnvp

         getlnvp = this%lnvp

      end function getlnvp
!
      function getlidprocm(this,m)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer, intent(in) :: m
         integer :: getlidprocm

         if (m == 1) then
            getlidprocm = this%lidproc
         else
            getlidprocm = this%lidprocm(m)
         end if

      end function getlidprocm
!
      function getlkstrtm(this,m)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer, intent(in) :: m
         integer :: getlkstrtm

         if (m == 1) then
            getlkstrtm = this%lkstrt
         else
            getlkstrtm = this%lkstrtm(m)
         end if
      end function getlkstrtm
!
      function getlgrpm(this,m)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer, intent(in) :: m
         integer :: getlgrpm

         if (m == 1) then
            getlgrpm = this%lgrp
         else
            getlgrpm = this%lgrpm(m)
         end if
      end function getlgrpm
!
      function getlnvpm(this,m)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer, intent(in) :: m
         integer :: getlnvpm

         if (m == 1) then
            getlnvpm = this%lnvp
         else
            getlnvpm = this%lnvpm(m)
         end if
      end function getlnvpm
!
      function getnstage(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getnstage

         getnstage = this%nstage

      end function getnstage
!
      function getstageid(this)

         implicit none

         class(parallel_pipe), intent(in) :: this
         integer :: getstageid

         getstageid = this%stageid

      end function getstageid
!
      subroutine init_parallel_pipe(this,nst)
! split world into different stage
         implicit none

         class(parallel_pipe), intent(inout) :: this
         integer, intent(in) :: nst
! local data
         integer :: ierror
         integer :: idproc, llworld, nvp
         integer :: lnvp, stageid, lidproc, llgrp

         call this%parallel%new
         idproc = this%getidproc()
         llworld = this%getlworld()
         nvp = this%getnvp()
         !lnvp processors each stage
         !lidproc id in one stage
         lnvp = nvp / nst
         this%nstage = nst
         lidproc = mod(idproc,lnvp)
         stageid = int(idproc/lnvp)
         !int MPI_Comm_split(MPI_Comm comm, int color, int key, MPI_Comm * newcomm)
         call MPI_COMM_SPLIT(llworld,stageid,lidproc,llgrp,ierror)
         call MPI_COMM_RANK(llgrp,this%lidproc,ierror)
         call MPI_COMM_SIZE(llgrp,this%lnvp,ierror)

         this%stageid = stageid
         this%lgrp = llgrp
         this%lkstrt = this%lidproc+1

         nproc = lnvp
         lgrp = llgrp
         lworld = llworld
         mreal = this%getmreal()
         mint = this%getmint()
         mcplx = this%getmcplx()
         mdouble = this%getmdouble()

      end subroutine init_parallel_pipe
!
      subroutine set_multigrid_parallel(this,color)
! split inside stage
         implicit none

         class(parallel_pipe), intent(inout) :: this
         integer, intent(in), dimension(:) :: color
! local data
         integer :: ierror, n, i
         integer :: llworld
         integer :: lnvp, stageid, lidproc, llgrp

!         llworld = this%getlworld()
         llworld = this%getlgrp()
         n = size(color)
         allocate(this%lidprocm(n),this%lkstrtm(n),this%lgrpm(n),this%lnvpm(n))
         do i = 1, n
            call MPI_COMM_SPLIT(llworld,color(i),this%lidproc,llgrp,ierror)
            call MPI_COMM_RANK(llgrp,lidproc,ierror)
            call MPI_COMM_SIZE(llgrp,lnvp,ierror)
            this%lgrpm(i) = llgrp
            this%lnvpm(i)= lnvp
            this%lidprocm(i) = lidproc
            this%lkstrtm(i) = lidproc + 1
         end do
      end subroutine set_multigrid_parallel

      subroutine renew_multigrid_parallel(this,color)
! split inside stage
         implicit none

         class(parallel_pipe), intent(inout) :: this
         integer, intent(in), dimension(:) :: color
! local data
         integer :: ierror, n, i
         integer :: llworld
         integer :: lnvp, stageid, lidproc, llgrp

         do i = 1, size(this%lgrpm)
           call MPI_COMM_FREE(this%lgrpm(i), ierror)
         end do
         
         deallocate(this%lidprocm,this%lkstrtm,this%lgrpm,this%lnvpm)
         llworld = this%getlgrp()
         n = size(color)
         allocate(this%lidprocm(n),this%lkstrtm(n),this%lgrpm(n),this%lnvpm(n))
         do i = 1, n
            call MPI_COMM_SPLIT(llworld,color(i),this%lidproc,llgrp,ierror)
            call MPI_COMM_RANK(llgrp,lidproc,ierror)
            call MPI_COMM_SIZE(llgrp,lnvp,ierror)
            this%lgrpm(i) = llgrp
            this%lnvpm(i)= lnvp
            this%lidprocm(i) = lidproc
            this%lkstrtm(i) = lidproc + 1
         end do

      end subroutine renew_multigrid_parallel
!
      end module parallel_pipe_class
